Whiteline: delta/whiteline CD Series - delta.iso/games/noah/noah.scr

Text File | 1995-11-25 | 45KB | 1 lines

\ NOAH's ARC a public domain game for the ATARI ST -->            Game idea and author Eric Hutton                                                                                              Collect animals by spelling their names on the 3 spining reels  of letters, before the food or spins run out. Hear the animal   sounds as you collect them. Runs in low/medium/high resolution.                                                                 Whenever a reel stops on a ? you are given two nudges and it    respins, animals can also be exchanged for nudges instead of    being put in the arc. Nudges can be exchanged for goes in the   lucky dip which contains extra food,spins or empty boxes.       Collecting "HAY" also gives +80 food                                                                                                                                                                                                                                                                                            \ NOAH's ARC game                                               \                                                               \ Runs under GEM Forth/ST v2 by MicroProcessor Engineering LTD. \ The program has been written assuming a 400x600 screen with   \ 4 colours. A modified GEM interface converts the xy points    \ at run time for other screen resolutions.                     \ A copy of the changes is appended to this source file                                                                         : listing ( -- )                                                  printer                                                         42 2 do i block c@ ascii \ = if i list then loop                console ;                                                                                                                                                                                                                                                                                                                     \ Load screen                                                   \ 1st load modified GEM.SCR                                     37 load \ define colour pallet                                  38 load \ defered animal noises                                 39 load \ replay subroutine BASCODE.EXE                         40 41 thru \ animal noises from ARC.SND directory               3 36 thru \ rest of the noah's arc game                                                                                         \ ;s                                                            \ create executable program......                               : (game) 0 blk ! r0 @ rp! game ;                                here 256 / 2+ 256 * hex 0128 ! \ set runtime forth size         assign (game)    to-do quit                                     assign appl-open to-do loader                                   save b:\NOAH                                                                                                                    \ definion primatives                                           : gotoxy ( x y -- x y ) swap x> swap gotoxy ;                   : outside   ( literal -- rubbish ) 0 swap ; immediate           0  constant false                                               -1 constant true                                                                                                                : sign+- ( n -- )                                                 0< if ascii - else ascii + then hold ;                                                                                        : -bounds ( addr n -- addr-1 addr+n )                             over + 1- ;                                                                                                                   : "hold ( addr -- )                                               count -bounds do i c@ hold -1 +loop ;                                                                                                                                                         \ keyboard input                                                : ?keydrop ( -- ) begin key? while key drop repeat ;            : lc ( char1 -- char1 ) dup 65 90 within? if 32 + then ;        : lower ( addr len -- ) \ if upper case convert to lower case     bounds ?do i c@ lc i c! loop ;                                : key_y/n? ( -- flag )                                            case key upc ascii Y of true  endof                                          ascii N of false endof next-case ;                                                                               : string ( n -- )  create dup c, allot  ( -- addr ) does> ;     : keyin ( addr -- )                                               cursor-on ?keydrop  dup count blank  dup count expect           count lower  cursor-off ;                                                                                                                                                                                                                                     \ define graphics                                               : shape create ( x y .... n -- ) dup , 0 do w, w, loop                  does>  dup @ swap 4+ swap fillarea ;                                                                                    : pattern create ( patern# style# colour -- ) , , , does>         dup @ vsf-colour 4+ 2@ vsf-pattern ;                                                                                                                                                          : outlined  16 vst-effects ;                                    : normal     0 vst-effects ;                                    : replace   replace vswr-mode ;                                 : transparent transparent vswr-mode ;                                                                                           : line ( x1 y1 x2 y2 -- )                                         2 pop-vertex  0 pop-intin  6 vdi-call ;                                                                                       \ define ARC & animals to collect                               create thearc  here                                               ", cow" 0 , 5 , 4 , ' moo       , ", daisy  "                   ", yak" 0 , 5 , 4 , ' yaknoise  , ", eric   "                   ", pig" 0 , 5 , 4 , ' grunt     , ", david  "                   ", cat" 0 , 2 , 2 , ' meow      , ", felix  "                   ", dog" 0 , 2 , 2 , ' bark      , ", snoopy "                   ", fox" 0 , 2 , 2 , ' howl      , ", basil  "                   ", bat" 0 , 1 , 2 , ' wing-flap , ", vince  "                   ", rat" 0 , 1 , 2 , ' scurry    , ", roland "                   ", owl" 0 , 1 , 2 , ' hoot      , ", teresa "                   ", hay" 0 , 0 , 4 , ' noop      , ",        "                 here - 10 / abs ( gives length of each entry )                  : animal ( animal# -- addr ) outside literal * thearc + ; drop                                                                                                                                  \ access contents of the arc                                    : cage+  4+ ;                                                   : feed+ 8+ ;                                                    9 constant hay                                                                                                                  : vacate ( animal# -- ) animal cage+ false swap ! ;             : occupy ( animal# -- ) animal cage+ true  swap ! ;             : collected? ( animal# -- flag ) animal cage+ @ ;                                                                               : empty-arc ( -- ) 10 0 do i vacate loop ;                      : arcfull? ( -- flag ) true                                      9 0 do i collected? if else drop false leave then loop ;                                                                       : animal>sound ( animal# -- ) animal 16 + @ execute ;           : animal>name ( animal# -- addr ) animal 20 + ;                                                                                 \ graphics                                                                                                                      : animal>xy ( animal# -- x y )                                    3 /mod 94 * 330 + swap 36 * 132 + ;                           : porthole+ ( x1 y1 -- x1 y1 x2 y2 )  over 84 + over 30 + ;     : name+ ( x y - x y)  22 + swap 10 + swap ;                     : .name ( animal# -- )                                            black vst-colour  16 vst-height  transparent                    dup animal count rot animal>xy name+ v-gtext ;                : .porthole ( animal# -- )  animal>xy porthole+ rfbox ;         2 8 brown pattern wooden                                        : .nameplate ( animal# -- ) dup wooden .porthole .name ;                                                                                                                                                                                                                                                                        \ graphics                                                                                                                      2 3 blue pattern grass                                          2 1 brown pattern soil                                                                                                          340 2  340 210  192 210 192 252  240 300  240 639  399 639      399 2  340 2    9 shape ground                                  : draw-ground   grass ground transparent soil ground replace ;                                                                  184 190  184 320  190 320  190 190 4 shape gangplank                                                                                                                                                                                                                                                                                                                                                                                                            \ graphics for lucky dip chest                                                                                                  2 24 brown pattern planked                                                                                                      332 340  332 540  380 540  380 340  332 340 5 shape chest                                                                                                                                       : .front_of_chest ( -- ) planked chest ;                        : .inside_chest  ( -- )  soil    chest ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        \ draw the arc                                                                                                                  120 300  120 628  240 598  240 330  120 300  5 shape hull                                                                       2 20 ochre pattern shingle                                      60 350  60 476  88 486  88 340  60 350 5 shape roof                                                                             2 9 brown pattern brick                                         88 360  88 466  120 466  120 360 90 360  5 shape cabin                                                                          : draw-arc ( -- ) planked hull  brick cabin  shingle roof         outlined 9 0 do i .nameplate loop ;                                                                                                                                                                                                                                                                                           \ define reels                                                  create (reels)  \ wound#  c string.... ( repeated 3 times )     here 0 ,  ", hypcdhfbrobdcrfpbocrhypc"  align                        0 ,  ", oai?owaoaaoaowiawo?aoai?"  align                        0 ,  ", ltxgtwktylxt?tywntygltxg"  align                   here - 3 /  abs  ( length of entry )                            : reel  ( reel# -- addr )  outside literal * (reels) + ; drop                                                                   64 constant reel-height                                         : reel>x ( reel# -- x ) 32 * 100 + ;                            : reel>y ( reel# -- y ) drop 60 ;                               : reel>ywin ( reel# -- y ) reel>y reel-height 2* + ;            : at+ 4+ ;                                                      : top+  at+ dup c@ + 1+ ;                                       : win+  top+ 2+ ;                                                                                                               \ show food and spins left                                      variable food                                                   variable feeding                                                                                                                : .food ( -- )                                                    60 6 gotoxy "" food " count type  food @ 4 .r ;                                                                               : food?   ( -- flag ) food @ 0> ;                               : nofood? ( -- flag ) food? not ;                                                                                               variable spin#                                                  : .spins ( -- )                                                   50 2 gotoxy "" SPINS " count type spin# @ 2 .r ;              : spins? ( -- flag ) spin# @ 0> ;                                                                                                                                                               \ define nudges                                                 create nudges ", 123456789" align                               variable #nudges                                                : nudge>xy ( n -- x y )                                           dup 1 and 32 * 10 + ( n x ) swap 32 * negate 360 + ;          : .nudge ( n -- ) ochre vst-colour  replace                       64 vst-height  dup nudges + 1 rot nudge>xy v-gtext ;          : nudges? ( -- flag )   #nudges @ 0 > ;                         : +nudge ( -- )   #nudges @ 9 < if                                1 #nudges +!  #nudges @ normal .nudge then ;                  : -nudge ( -- )  nudges? if                                       #nudges @ outlined .nudge -1 #nudges +! then ;                : draw-nudges ( -- )                                              outlined 10 1 do i .nudge loop                                  normal #nudges @ 1+ 1 ?do i .nudge loop                                40 vst-height  "" nudges" count 10 380 v-gtext ;       \ sea graphics                                                  : leftsea     ( n -- y x y x )                                    >r  330 r@ 4/ -   240 r@ -   300 r@ -  240 r> - ;             : rightsea    ( n -- y x y x )                                    >r  600 r@ 4/ +   240 r@ -   639       240 r> - ;                                                                             : seasurface ( n -- ) dup dup 1+ dup                              black vsl-colour  leftsea line rightsea line                    blue  vsl-colour  leftsea line rightsea line ;                                                                                : ?fillsea ( -- )                                                 spin# @ 40 < if 40 spin# @ - seasurface then ;                                                                                : +spin ( -- )  1 spin# +! ?fillsea ;                           : -spin ( -- ) -1 spin# +! ?fillsea ;                                                                                           \ help text                                                     : helpline ( n -- ) 15 + 30 swap gotoxy ;                       : .spaces ( -- )  22 spaces ;                                   : erasetext ( -- )                                                5 1 do i helpline .spaces loop ;                              : moretext ( -- )                                                 7000 ms  bell erasetext 200 ms ;                                                                                              defer restart.message                                           assign noop to-do restart.message                               defer .message                                                  : ?message ( -- )  .message assign noop to-do .message ;                                                                                                                                                                                                                                                                        \ define lucky dip                                              create "food"     ", food "     align                           create "spins"    ", spins "    align                           create "emptybox" ", empty box" align                           create (dip)                                                      10 , "food" ,       0 , "emptybox" ,    10 , "food" ,            0 , "emptybox" ,   5 , "spins" ,       30 , "food" ,            0 , "emptybox" ,  10 , "food" ,         5 , "spins" ,                                                                        : pickdip ( -- addr n )                                           random# 9 mod 8 * (dip) + 2@ ;                                : ?foodwin ( n addr -- )                                          "food" = if food +! .food else drop then ;                    : ?spinswin ( n addr -- )                                         "spins" = if 0 do +spin loop .spins else drop then ;                                                                          \ lucky dip                                                     : .contents ( addr n colour# -- )  vst-colour normal              transparent  32 vst-height 350 368 v-gtext replace ;                                                                          : draw-chest ( -- )                                               .front_of_chest "" lucky dip" count blue .contents ;                                                                          : <#dip> ( addr n -- )                                            dup s>d dabs  <# #s  bl hold rot sign+- rot "hold #> ;                                                                        : luckydip ( -- )                                                 pickdip 2dup ?dup 0<> if <#dip> else count then                 .inside_chest  blue .contents                                   swap 2dup ?foodwin ?spinswin 1000 ms draw-chest ;                                                                                                                                             \ decide if winning line                                                                                                        variable win-line                                                                                                               : win! ( reel# -- )                                               3 win-line c!  dup reel win+ c@ swap win-line + 1+ c! ;                                                                       : win? ( -- animal# flag ) 0 false 10 0                          do i animal @ win-line @ = if 2drop i true leave then loop ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                   \ display reels                                                 variable vst-x                                                  : .reel-down ( addr len x y -- )                                  swap vst-x ! swap reel-height * bounds                          do dup 1 vst-x @ i v-gtext  1+ reel-height +loop drop ;       : .reel ( reel# -- ) >r                                           replace normal reel-height  vst-height                          blue vst-colour                                                 r@ reel top+  5  r@ reel>x  r> reel>y .reel-down ;            : .reels ( -- ) 3 0 do i .reel loop ;                                                                                           : .win ( reel# -- ) >r                                            replace  2 vst-effects reel-height vst-height                   blue vst-colour                                                 r@ reel win+  1  r@ reel>x  r> reel>ywin v-gtext ;                                                                            \ reel movement                                                 : position  ( movement+- reel# -- ) dup >r                         reel at+ swap over c@ + 20 mod swap c! r@ win! r> .reel ;                                                                    1  constant up                                                  -1 constant down                                                : wound? ( addr -- flag ) @ 0> ;                                : anywoundup? ( -- flag )                                         false 3 0 do i reel wound? or loop ;                                                                                          : windreel ( reel# -- )  random# 8 mod 15 + swap reel ! ;                                                                       : windreels ( -- ) 3 0 do i windreel loop ;                                                                                                                                                                                                                     \ reel movement                                                                                                                 : (spin)  ( -- )  begin anywoundup? while                         3 0 do i reel wound? if -1 i reel +!  down i position           else 20 ms then loop repeat ;                                                                                                 : +nudges ( n -- ) 0 do +nudge loop ;                           : animal>nudges ( animal# -- ) animal 12 + @ +nudges ;                                                                          : spin ( -- )                                                     -nudge  -spin  .spins  windreels (spin) ;                                                                                     : ?respin ( -- ) 3 0                                              do i reel win+ c@ ascii ? = if 2 +nudges i windreel then loop   anywoundup? if bell 1000 ms (spin) recurse then ;                                                                             \ show if line win                                              : 0win ( -- ) 0 win-line ! 0 .win 1 .win 2 .win ;                                                                               : eat ( -- )  feeding @ negate food +! .food ;                                                                                  : exchange ( -- )                                                 win? if 0win animal>nudges                                         else drop nudges? if -nudge luckydip then then ;                                                                           : .copyright ( -- )                                                   189 emit ""  Eric Hutton 1989    " count type ;           : .credits ( -- )                                                 1 helpline  "" NOAH's ARC is a public" count type               2 helpline  "" domain program.       " count type               3 helpline  "" Press HELP for rules  " count type               4 helpline  .copyright ;                                      \ show if line win                                                                                                              : .collect_rule ( -- )                                            1 helpline  "" To collect an animal  " count type               2 helpline  "" spell its name level  " count type               3 helpline  "" with the gangplank.   " count type               4 helpline  .spaces moretext .credits ;                                                                                       : collect ( -- )                                                  win? if 0win dup occupy                                                 dup hay = if  drop 80 food +! .food                                     else  500 ms dup animal>sound                                         dup normal .nameplate                                           animal feed+ @ feeding +! then               else .collect_rule drop then ;                                                                                             \ help text                                                                                                                     : .lucky_dip_is ( -- )                                            1 helpline  "" Press E to exchange   " count type               2 helpline  "" a nudge for a go on   " count type               3 helpline  "" the lucky dip.        " count type               4 helpline  .spaces                                             assign .credits to-do .message ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              \ help text                                                     : .hint#1 ( -- )                                                  2 helpline  "" The largest animals   " count type               3 helpline  "" eat the most food.    " count type               4 helpline  .spaces ;                                                                                                         : .hint#2 ( -- )                                                  2 helpline  "" Collecting hay gives  " count type               3 helpline  "" +80 food              " count type               4 helpline  .spaces ;                                                                                                         : .hint#3 ( -- )                                                  2 helpline  "" Animals on the winning" count type               3 helpline  "" line can be exchanged " count type               4 helpline  "" for nudges. Use E key " count type ;                                                                           \ give prize for filling the arc up                             3 string called                                                 : animal? ( -- animal# flag )                                     0 false 9 0 do i animal @ called @ = if                         2drop i true leave then loop ;                                                                                                : .welldone ( -- )                                                erasetext                                                       1 helpline  "" Well done.            " count type               2 helpline  "" Pick an animal? "      count type                begin called keyin animal? until                                3 helpline  "" Its name is "          count type                                          animal>name count type                4 helpline  "" Try calling out to it " count type moretext ;                                                                                                                                  \ game abandoned or run out of food/spins                       : .giveup ( -- )                                                  erasetext                                                       1 helpline  "" Game abandoned        " count type ;           : .gameover ( -- )                                                1 helpline  "" Game over.            " count type               nofood? if hay collected? if .hint#1 else .hint#2 then then     food? if .hint#3 then                                           moretext ;                                                                                                                    : yakfact ( -- )                                                  1 helpline  "" Yaks come from Tibet  " count type               2 helpline  "" bred by monks who are " count type               3 helpline  "" under a vow of silence" count type               4 helpline  "" Yaks are very quiet..." count type               moretext .credits ;                                           \ help text                                                     : .aim-of-game ( -- )                                             1 helpline  "" Spin reels, & collect " count type               2 helpline  "" one of each animal to " count type               3 helpline  "" fill the arc before   " count type               4 helpline  "" the time runs out...  " count type               moretext .credits ;                                           : .keys ( -- )                                                    1 helpline  "" S=spin     C=collect  " count type               2 helpline  "" G=give up  E=exchange " count type               3 helpline  "" 789=nudge reels up    " count type               4 helpline  "" 456=nudge reels down  " count type               assign .credits to-do .message ;                                                                                                                                                                                                                              \ help text                                                     7 string callto                                                                                                                 : name? ( -- animal# flag )                                       0 false 9 0 do i animal>name callto 7 s= if                     2drop i true leave then loop ;                                                                                                : callanimal ( -- )                                               erasetext                                                       2 helpline  "" Each time you fill up " count type               3 helpline  "" the ARC your prize is " count type               4 helpline  "" the name of an animal " count type               1 helpline  "" animals name? "         count type               callto keyin                                                    name? if 500 ms animal>sound else drop then .credits ;                                                                        \ help text                                                                                                                     : .help-menu ( -- )                                               1 helpline  "" 1. aim of the game    " count type               2 helpline  "" 2. what keys do       " count type               3 helpline  "" 3. using the lucky dip" count type               4 helpline  "" 4. call out to animal " count type ;                                                                           : help ( -- ) .help-menu case key                                 ascii 1 of .aim-of-game  endof                                  ascii 2 of .keys         endof                                  ascii 3 of .lucky_dip_is endof                                  ascii 4 of callanimal    endof .credits endcase ;                                                                                                                                                                                                             \ food has run out                                              create "no"        ", no " align                                : .nofood ( -- )                                                  erasetext                                                       1 helpline "" The food has run out." count type                 3 helpline "" If you can't type no " count type                 2 helpline "" Sacrifice animal? "    count type ;                                                                             : nosacrifice? ( -- flag ) called @ "no" @ = ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  \ food has run out                                              : animal>food ( animal# -- )                                      dup vacate   dup outlined .nameplate                            animal feed+ @ dup negate feeding +! 10 * food +! ;                                                                           : sacrifice ( animal# -- )                                        dup collected? if animal>food .food else drop then ;                                                                          : food-runout ( -- )                                              begin .nofood called keyin animal? if sacrifice else drop then  food? nosacrifice? or until .credits ;                                                                                                                                                                                                                                                                                                                                                        \ starting up a new game                                        : draw-game ( -- ) v-clrwk                                        draw-ground  draw-arc  draw-nudges  planked gangplank           draw-chest   .spins  .food .credits ;                                                                                         : init ( -- )                                                     appl-open cursor-off set-colour-pallet                          assign noop to-do .message  assign yakfact to-do yaknoise ;                                                                   : start ( -- )                                                    0 feeding ! 120 food !  3 #nudges !  50 spin# !                 empty-arc windreels  draw-game (spin) ?respin                   assign .giveup to-do restart.message ;                                                                                        : finish ( -- )  appl-close cursor-on quit ;                                                                                    \ decide if game over                                           : ?restart ( -- )                                                 restart.message                                                 4 helpline "" another game y/n ?    " count type                key_y/n? if start else bye then ;                             : gameover ( -- )                                                 assign .gameover to-do restart.message  ?restart ;            : reward ( -- )                                                   assign .welldone to-do restart.message  ?restart ;            : ?gameover ( -- ) arcfull? if reward then                        win? nip nudges? or if else                                     spins? if else gameover then                                    nofood? if food-runout nofood? if gameover then then            then ;                                                                                                                                                                                        \ Top level program loop                                        : game ( -- )   init start begin case evnt-keybd ?message       25088 of help endof 255 and ( mask ascii ) lc                   ascii c of collect    endof   ascii g of ?restart endof         ascii e of exchange   endof                                     ascii s of spins? if eat spin else .lucky_dip_is then endof     ascii 7 of nudges? if -nudge up 0 position then endof           ascii 8 of nudges? if -nudge up 1 position then endof           ascii 9 of nudges? if -nudge up 2 position then endof           ascii 4 of nudges? if -nudge down 0 position then endof         ascii 5 of nudges? if -nudge down 1 position then endof         ascii 6 of nudges? if -nudge down 2 position then endof         ( test ) \ ascii 0 of finish endof    ascii * of -spin  endof   ( test ) \ ascii + of +nudge endof    ascii - of -nudge endof   endcase  ?respin ?gameover ?keydrop again ;                                                                                     \ define colour pallet                                                                                                          0 constant black                                                1 constant ochre                                                2 constant brown                                                3 constant blue                                                 : set-colour-pallet ( -- )                                      black 0    0    0    vs-colour                                  ochre 1000 1000 0    vs-colour                                  brown 1000 720  0    vs-colour                                  blue  0    1000 1000 vs-colour ;                                                                                                                                                                                                                                                                                                                                                                \ define animal noises ( silent so far )                                                                                        defer moo        ( pig ) assign noop to-do moo                  defer yaknoise   ( yak ) assign noop to-do yaknoise             defer grunt      ( pig ) assign noop to-do grunt                defer meow       ( cat ) assign noop to-do meow                 defer bark       ( dog ) assign noop to-do bark                 defer howl       ( fox ) assign noop to-do howl                 defer wing-flap  ( bat ) assign noop to-do wing-flap            defer scurry     ( rat ) assign noop to-do scurry               defer hoot       ( owl ) assign noop to-do hoot                                                                                                                                                                                                                                                                                                                                                 \ Load assembler routine to replay digital sounds               asm                                                             code (replay) l$1 bsr, next,                                    l$1: 2800 allot end-code                                        unhook-asm                                                                                                                      pcb r.exe                                                       r.exe pathname bascode.exe  r.exe open-path-pcb .               28 r.exe handle seek-path .                                                                                                     ' (replay) >body 12 + constant r.entry                          r.entry 2794 28 - r.exe handle read-path . .                                                                                    : replay ( addr n freq -- )                                       r.entry 10 + !  r.entry 6 + !  bp+ r.entry 2+ ! (replay) ;                                                                    \ call replay routine                                                                                                           4 constant 20khz                                                2 constant 10khz                                                                                                                pcb *.spl                                                       : soundof  \ eg  6960 10khz soundof hoot                          create , dup , here over allot swap                                    *.spl open-path-pcb .  *.spl handle read-path . .        does> 8+ dup 8- 2@ replay ;                                                                                                                                                                                                                                                                                                                                                                                                                                   \ load sound samples                                                                                                            *.spl pathname ARC.SND\COW.SPL    9332 10khz soundof moo        *.spl pathname ARC.SND\PIG_1.SPL  5126 10khz soundof grunt#1    *.spl pathname ARC.SND\PIG_2.SPL  9270 10khz soundof grunt#2    : grunt ( -- ) grunt#1 400 ms grunt#2 ;                         *.spl pathname ARC.SND\CAT.SPL   10048 10khz soundof meow       *.spl pathname ARC.SND\DOG.SPL    4080 20khz soundof bark#1     : bark  ( -- ) bark#1  400 ms bark#1 ;                          *.spl pathname ARC.SND\OWL.SPL    9746 10khz soundof hoot       *.spl pathname ARC.SND\FOX.SPL   14134 10khz soundof howl       *.spl pathname ARC.SND\RAT.SPL    5334 10khz soundof scurry     *.spl pathname ARC.SND\BAT.SPL   12740 10khz soundof wing-flap                                                                                                                                                                                                  \ Copy of GEM interface changes                                 \ scale screen x y for low/med/hi res..........E H 11Oct89                                                                      defer x> assign noop to-do x>                                   defer y> assign noop to-do y>                                                                                                   : scale>ptsin ( #xypairs -- )                                     ?dup if 0 ptsin swap 4* bounds                                  do i w@ x> i w!  i 2+ w@ y> i 2+ w! 4 +loop then ;                                                                            : .ptsin ( #xypairs -- ) \ for test purposes only                 ?dup if 0 ptsin swap 4* bounds                                  do i w@ . i 2+ w@ . 4 +loop then ;                                                                                                                                                                                                                            \ Copy of GEM interface changes                                                                                                 : assign.xy ( -- )                                                assign noop to-do x>  assign noop to-do y>                      screen-height @ 200 = if assign 2/ to-do y> then                screen-width  @ 320 = if assign 2/ to-do x> then ;                                                                            \ change the following words in GEM.SCR                         \                                                               \ pop-vertex >r r@  ......... >r scale>ptsin ;                  \ vertex-in  >r r@  ......... >r scale>ptsin ;                  \ appl-open  ........... assign-xy ;